home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / CScheme / extend-syntax-6.x.scm < prev    next >
Encoding:
Text File  |  1993-07-16  |  15.3 KB  |  421 lines
  1. ;;; extend-syntax.scm
  2. ;;; August 7, 1989
  3. ;;; Ported from chez to mitscheme M. Radle, M. Montenyohl and E. Elberson
  4. ;;; new macros include:  when, unless,  and
  5. ;;; kerror ('k' to differentiate from mitscheme's 'error' function.)
  6. ;;; The following functions were added:
  7. ;;;  gensym, duplicate-symbols, box, unbox, set-box!.
  8.  
  9.  
  10. (define gensym generate-uninterned-symbol)
  11.  
  12. (define-macro (unless cond . e1 ) `(if (not ,cond) (begin ,@e1)))
  13.  
  14. (define-macro (when cond . e1) `(if ,cond (begin ,@e1) ))
  15.  
  16. (define-macro (kerror msg-line . args)
  17.   `(begin
  18.      (format ,msg-line ,@args)
  19.      (error " ")))
  20.  
  21.  
  22.  
  23.  
  24. ;;; extend.ss
  25. ;;; Copyright (C) 1987 R. Kent Dybvig
  26. ;;; Permission to copy this software, in whole or in part, to use this
  27. ;;; software for any lawful purpose, and to redistribute this software
  28. ;;; is granted subject to the restriction that all copies made of this
  29. ;;; software must include this copyright notice in full.
  30.  
  31. ;;; The basic design of extend-syntax is due to Eugene Kohlbecker.  See
  32. ;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
  33. ;;; Ph.D.  Dissertation, Indiana University, 1986."  The structure of "with"
  34. ;;; pattern/value clauses, the method for compiling extend-syntax into
  35. ;;; Scheme code, and the actual implementation are due to Kent Dybvig.
  36.  
  37.  
  38. ;;; August 7, 1989
  39. ;;; We modified Kent's original code as follows:
  40. ;;;     . use define-macro to define extend-syntax
  41. ;;;    . All 'defines' are nested inside the definition of extend-syntax.
  42. ;;;    . Syntax-Match? had to be defined local to extend-syntax's definition
  43. ;;;       and local to the call to define-macro that appears in the 
  44. ;;;      expansion for extend-syntax. (see bottom of file).
  45.  
  46. (define-macro (extend-syntax keys . clauses)
  47.  
  48. (define syntax-match?
  49.    (lambda (pat exp)
  50.       (or (eq? pat '*)
  51.           (eq? exp pat)
  52.           (and (pair? pat)
  53.                (cond
  54.                   ((and (eq? (car pat) '\\)
  55.                         (pair? (cdr pat))
  56.                         (null? (cddr pat)))
  57.                    (eq? exp (cadr pat)))
  58.                   ((and (pair? (cdr pat))
  59.                         (eq? (cadr pat) '...)
  60.                         (null? (cddr pat)))
  61.                    (let ((pat (car pat)))
  62.                       (let f ((lst exp))
  63.                          (or (null? lst)
  64.                              (and (pair? lst)
  65.                                   (syntax-match? pat (car lst))
  66.                                   (f (cdr lst)))))))
  67.                   (else
  68.                    (and (pair? exp)
  69.                         (syntax-match? (car pat) (car exp))
  70.                         (syntax-match? (cdr pat) (cdr exp)))))))))
  71.  
  72.  
  73.  
  74.  
  75.    (define gensym generate-uninterned-symbol)
  76.    (define box (lambda (x) (cons x #f)))
  77.    (define unbox (lambda (x) (car x)))
  78.    (define set-box! (lambda (x v) (set-car! x v)))
  79.     
  80.    (define duplicate-symbols
  81.         (lambda ( list )
  82.                 (unless (null? list)
  83.                          (when (memq (car list) (cdr list)) (cons (car list)
  84.                               ( duplicate-symbols (cdr list)))))))
  85.  
  86.  
  87.  
  88.    (define id
  89.       (lambda (name access control)
  90.          (list name access control)))
  91.    (define id-name car)
  92.    (define id-access cadr)
  93.    (define id-control caddr)
  94.  
  95.    (define loop
  96.       (lambda ()
  97.          (box '())))
  98.    (define loop-ids unbox)
  99.    (define loop-ids! set-box!)
  100.  
  101.    (define c...rs
  102.       `((car caar . cdar)
  103.         (cdr cadr . cddr)
  104.         (caar caaar . cdaar)
  105.         (cadr caadr . cdadr)
  106.         (cdar cadar . cddar)
  107.         (cddr caddr . cdddr)
  108.         (caaar caaaar . cdaaar)
  109.         (caadr caaadr . cdaadr)
  110.         (cadar caadar . cdadar)
  111.         (caddr caaddr . cdaddr)
  112.         (cdaar cadaar . cddaar)
  113.         (cdadr cadadr . cddadr)
  114.         (cddar caddar . cdddar)
  115.         (cdddr cadddr . cddddr)))
  116.  
  117.    (define add-car
  118.       (lambda (access)
  119.          (let ((x (and (pair? access) (assq (car access) c...rs))))
  120.             (if (null? x)
  121.                 `(car ,access)
  122.                 `(,(cadr x) ,@(cdr access))))))
  123.  
  124.    (define add-cdr
  125.       (lambda (access)
  126.          (let ((x (and (pair? access) (assq (car access) c...rs))))
  127.             (if (null? x)
  128.                 `(cdr ,access)
  129.                 `(,(cddr x) ,@(cdr access))))))
  130.  
  131.  
  132.    (define checkpat
  133.       (lambda (keys pat exp)
  134.          (let ((vars (let f ((x pat) (vars '()))
  135.                         (cond
  136.                            ((pair? x)
  137.                             (if (and (pair? (cdr x))
  138.                                      (eq? (cadr x) '...)
  139.                                      (null? (cddr x)))
  140.                                 (f (car x) vars)
  141.                                 (f (car x) (f (cdr x) vars))))
  142.                            ((symbol? x)
  143.                             (cond
  144.                                ((memq x keys) vars)
  145.                                ((or (eq? x 'with) (eq? x '...))
  146.                                  (kerror
  147.                                   "EXTEND-SYNTAX: Invalid context for ~o in ~o"
  148.                                   x exp))
  149.                                (else (cons x vars))))
  150.                            (else vars)))))
  151.             (let ((dupls (duplicate-symbols vars)))
  152.                (unless (null? dupls)
  153.                 (kerror "EXTEND-SYNTAX: duplicate pattern variable name ~o in ~o"
  154.                 (car dupls) exp))))))
  155.  
  156.    (define parse
  157.       (lambda (keys pat acc cntl ids)
  158.          (cond
  159.             ((symbol? pat)
  160.              (if (memq pat keys)
  161.                  ids
  162.                  (cons (id pat acc cntl) ids)))
  163.             ((pair? pat)
  164.              (cons (id pat acc cntl)
  165.                    (if (equal? (cdr pat) '(...))
  166.                        (let ((x (gensym)))
  167.                           (parse keys (car pat) x (id x acc cntl) ids))
  168.                        (parse keys (car pat) (add-car acc) cntl
  169.                           (parse keys (cdr pat) (add-cdr acc) cntl ids)))))
  170.             (else ids))))
  171.  
  172.    (define pattern-variable?
  173.       (lambda (sym ids)
  174.          (memq sym (map id-name ids))))
  175.  
  176.    (define gen
  177.       (lambda (keys exp ids loops qqlev)
  178.          (cond
  179.             ((lookup exp ids) =>
  180.              (lambda (id)
  181.                 (add-control! (id-control id) loops)
  182.                 (list 'unquote (id-access id))))
  183.             ((not (pair? exp)) exp)
  184.             (else
  185.              (cond
  186.                 ((and (syntax-match? '(quasiquote *) exp)
  187.                       (not (pattern-variable? 'quasiqote ids)))
  188.                  (list 'unquote
  189.                        (list 'list
  190.                              ''quasiquote
  191.                              (make-quasi
  192.                                 (gen keys (cadr exp) ids loops
  193.                                      (if (= qqlev 0) 0 (+ qqlev 1)))))))
  194.                 ((and (syntax-match? '(* *) exp)
  195.                       (memq (car exp) '(unquote unquote-splicing))
  196.                       (not (pattern-variable? (car exp) ids)))
  197.                  (list 'unquote
  198.                        (list 'list
  199.                              (list 'quote (car exp))
  200.                              (make-quasi
  201.                                 (if (= qqlev 1)
  202.                                     (gen-quotes keys (cadr exp) ids loops)
  203.                                     (gen keys (cadr exp) ids loops
  204.                                          (- qqlev 1)))))))
  205.                 ((and (eq? (car exp) 'with)
  206.                       (not (pattern-variable? 'with ids)))
  207.                  (unless (syntax-match? '(with ((* *) ...) *) exp)
  208.                     (kerror "EXTEND-SYNTAX: invalid 'with' form ~o" exp))
  209.                  (checkpat keys (map car (cadr exp)) exp)
  210.                  (list 'unquote
  211.                     (gen-with
  212.                        keys
  213.                        (map car (cadr exp))
  214.                        (map cadr (cadr exp))
  215.                        (caddr exp)
  216.                        ids
  217.                        loops)))
  218.                 ((and (pair? (cdr exp)) (eq? (cadr exp) '...))
  219.                  (let ((x (loop)))
  220.                     (gen-cons (list 'unquote-splicing
  221.                                     (make-loop x (gen keys (car exp) ids
  222.                                                       (cons x loops) qqlev)))
  223.                               (gen keys (cddr exp) ids loops qqlev))))
  224.                 (else
  225.                  (gen-cons (gen keys (car exp) ids loops qqlev)
  226.                            (gen keys (cdr exp) ids loops qqlev))))))))
  227.  
  228.    (define gen-cons
  229.       (lambda (head tail)
  230.          (if (null? tail)
  231.              (if (syntax-match? '(unquote-splicing *) head)
  232.                  (list 'unquote (cadr head))
  233.                  (cons head tail))
  234.              (if (syntax-match? '(unquote *) tail)
  235.                  (list head (list 'unquote-splicing (cadr tail)))
  236.                  (cons head tail)))))
  237.  
  238.    (define gen-with
  239.       (lambda (keys pats exps body ids loops)
  240.          (let ((temps (map (lambda (x) (gensym)) pats)))
  241.             `(let (,@(map (lambda (t e) `(,t ,(gen-quotes keys e ids loops)))
  242.                           temps
  243.                           exps))
  244.                 ,@(let f ((pats pats) (temps temps))
  245.                      (if (null? pats)
  246.                          '()
  247.                          (let ((m (match-pattern '() (car pats)))
  248.                                (rest (f (cdr pats) (cdr temps))))
  249.                             (if (eq? m '*)
  250.                                 (f (cdr pats) (cdr temps))
  251.                                 `((unless (syntax-match? ',m ,(car temps))
  252.                                      (kerror "~o: ~o does not fit 'with' pattern ~o"
  253.                                       ',(car keys)
  254.                                       ,(car temps)
  255.                                       ',(car pats)))
  256.                                   ,@(f (cdr pats) (cdr temps)))))))
  257.                 ,(let f ((pats pats) (temps temps) (ids ids))
  258.                     (if (null? pats)
  259.                         (make-quasi (gen keys body ids loops 0))
  260.                         (f (cdr pats)
  261.                            (cdr temps)
  262.                            (parse '() (car pats) (car temps) '() ids))))))))
  263.  
  264.    (define gen-quotes
  265.       (lambda (keys exp ids loops)
  266.          (cond
  267.             ((syntax-match? '(quote *) exp)
  268.              (make-quasi (gen keys (cadr exp) ids loops 0)))
  269.             ((syntax-match? '(quasiquote *) exp)
  270.              (make-quasi (gen keys (cadr exp) ids loops 1)))
  271.             ((pair? exp)
  272.              (let f ((exp exp))
  273.                 (if (pair? exp)
  274.                     (cons (gen-quotes keys (car exp) ids loops)
  275.                           (f (cdr exp)))
  276.                     (gen-quotes keys exp ids loops))))
  277.             (else exp))))
  278.  
  279.    (define lookup
  280.       (lambda (exp ids)
  281.          (let loop ((ls ids))
  282.             (cond
  283.                ((null? ls) #f)
  284.                ((equal? (id-name (car ls)) exp) (car ls))
  285.                ((subexp? (id-name (car ls)) exp) #f)
  286.                (else (loop (cdr ls)))))))
  287.  
  288.    (define subexp?
  289.       (lambda (exp1 exp2)
  290.          (and (symbol? exp1)
  291.               (let f ((exp2 exp2))
  292.                  (or (eq? exp1 exp2)
  293.                      (and (pair? exp2)
  294.                           (or (f (car exp2))
  295.                               (f (cdr exp2)))))))))
  296.  
  297.    (define add-control!
  298.       (lambda (id loops)
  299.          (unless (null? id)
  300.             (when (null? loops)
  301.                (kerror "EXTEND-SYNTAX: missing ellipsis in expansion"))
  302.             (let ((x (loop-ids (car loops))))
  303.                (unless (memq id x)
  304.                   (loop-ids! (car loops) (cons id x))))
  305.             (add-control! (id-control id) (cdr loops)))))
  306.  
  307.    (define make-loop
  308.       (lambda (loop body)
  309.          (let ((ids (loop-ids loop)))
  310.             (when (null? ids)
  311.                (kerror "EXTEND-SYNTAX: extra ellipsis in expansion"))
  312.             (cond
  313.                ((equal? body (list 'unquote (id-name (car ids))))
  314.                 (id-access (car ids)))
  315.                ((and (null? (cdr ids))
  316.                      (syntax-match? '(unquote (* *)) body)
  317.                      (eq? (cadadr body) (id-name (car ids))))
  318.                 `(map ,(caadr body) ,(id-access (car ids))))
  319.                (else
  320.                 `(map (lambda ,(map id-name ids) ,(make-quasi body))
  321.                       ,@(map id-access ids)))))))
  322.  
  323.    (define match-pattern
  324.       (lambda (keys pat)
  325.          (cond
  326.             ((symbol? pat)
  327.              (if (memq pat keys)
  328.                  (if (memq pat '(* \\ ...))
  329.                      `(\\ ,pat)
  330.                      pat)
  331.                  '*))
  332.             ((pair? pat)
  333.              (if (and (pair? (cdr pat))
  334.                       (eq? (cadr pat) '...)
  335.                       (null? (cddr pat)))
  336.                  `(,(match-pattern keys (car pat)) ...)
  337.                  (cons (match-pattern keys (car pat))
  338.                        (match-pattern keys (cdr pat)))))
  339.             (else pat))))
  340.          
  341.    (define make-quasi
  342.       (lambda (exp)
  343.          (if (and (pair? exp) (eq? (car exp) 'unquote))
  344.              (cadr exp)
  345.              (list 'quasiquote exp))))
  346.  
  347.  
  348.  
  349.  
  350.    (define make-clause
  351.       (lambda (keys cl x)
  352.          (cond
  353.             ((syntax-match? '(* * *) cl)
  354.              (let ((pat (car cl)) (fender (cadr cl)) (exp (caddr cl)))
  355.                 (checkpat keys pat pat)
  356.                 (let ((ids (parse keys pat x '() '())))
  357.                    `((and (syntax-match? ',(match-pattern keys pat) ,x)
  358.                           ,(gen-quotes keys fender ids '()))
  359.                      ,(make-quasi (gen keys exp ids '() 0))))))
  360.             ((syntax-match? '(* *) cl)
  361.              (let ((pat (car cl)) (exp (cadr cl)))
  362.                 (checkpat keys pat pat)
  363.                 (let ((ids (parse keys pat x '() '())))
  364.                    `((syntax-match? ',(match-pattern keys pat) ,x)
  365.                      ,(make-quasi (gen keys exp ids '() 0))))))
  366.             (else
  367.              (kerror "EXTEND-SYNTAX: invalid clause ~o" cl)))))
  368.  
  369.    (define make-syntax
  370.       (let ((x (string->uninterned-symbol "x")))
  371.          (lambda (keys clauses)
  372.             (when (memq '... keys)
  373.                (kerror "EXTEND-SYNTAX: invalid keyword ... in keyword list ~o"
  374.                        keys))
  375.             `(lambda (,x)
  376.                 (cond
  377.                    ,@(map (lambda (cl) (make-clause keys cl x)) clauses)
  378.                    (else
  379.                     (kerror "~o: invalid syntax ~o" ',(car keys) ,x)))
  380.                    ))))
  381.  
  382.  
  383.  
  384.          `(define-macro (,(car keys) . body)
  385.  
  386. ;;;  The following definition of syntax-match? is necessary so that the
  387. ;;;  macro being defined will have the proper environment. MIT macro
  388. ;;;  expander can't see run-time environment (?)
  389.  
  390.  
  391. (define syntax-match?
  392.    (lambda (pat exp)
  393.       (or (eq? pat '*)
  394.           (eq? exp pat)
  395.           (and (pair? pat)
  396.                (cond
  397.                   ((and (eq? (car pat) '\\)
  398.                         (pair? (cdr pat))
  399.                         (null? (cddr pat)))
  400.                    (eq? exp (cadr pat)))
  401.                   ((and (pair? (cdr pat))
  402.                         (eq? (cadr pat) '...)
  403.                         (null? (cddr pat)))
  404.                    (let ((pat (car pat)))
  405.                       (let f ((lst exp))
  406.                          (or (null? lst)
  407.                              (and (pair? lst)
  408.                                   (syntax-match? pat (car lst))
  409.                                   (f (cdr lst)))))))
  410.                   (else
  411.                    (and (pair? exp)
  412.                         (syntax-match? (car pat) (car exp))
  413.                         (syntax-match? (cdr pat) (cdr exp)))))))))
  414.  
  415.  
  416.  
  417.              (,(make-syntax keys clauses)  (cons ',(car keys) body))))
  418.  
  419.  
  420.  
  421.